home *** CD-ROM | disk | FTP | other *** search
/ CICA 1993 April / CICA MS Windows - April 1993.iso / unzipped / programr / bcpp / cmmdlg / comosamp.pas < prev    next >
Pascal/Delphi Source File  |  1992-09-16  |  12KB  |  479 lines
  1.  
  2. {***************************************************}
  3. {                                                   }
  4. {   Turbo Pascal for Windows                        }
  5. {   Windows 3.1 Common Dialogs Demo Program         }
  6. {                                                   }
  7. {   Copyright (c) 1992 by Borland International     }
  8. {   modifications for tCommonDlg object by          }
  9. {%%                              Juancarlo A±ez     }
  10. {%%                              [73000, 1064]      }
  11. {%%                               August 1992        } 
  12. {                                                   }
  13. {***************************************************}
  14.  
  15.  
  16. PROGRAM CommDlgs;
  17.  
  18. { This program demonstrates the use of several new Windows 3.1
  19.   features: The Common Dialogs (for Font and Color selection),
  20.   True Type, and Playing sounds.
  21. }
  22.  
  23. {%% THIS PROGRAM ALSO SHOWS HOW TO USE THE tCommonDlg OBJECT AND ITS
  24.     DESCENDANTS, AND THE PRN31 UNIT, A WIN 3.1 AWARE VERSION OF
  25.     PRINTER.PAS IN CIS LIB 8
  26.  
  27.     I TESTED THIS APP WITH THE FOLOWING OPTIONS
  28. }
  29. {$A+,B-,D+,F-,G+,I+,L+,N+,R+,S+,V-,W-,X+}
  30.  
  31. USES
  32.   WinCrt,
  33.   WinDos,
  34.   Strings,
  35.   WinTypes,
  36.   WinProcs,
  37.   WObjects,
  38.   CommDlg,
  39.   MMSystem,
  40.   BWCC,
  41.  
  42.   {following  units added by me
  43.   {
  44.     \\\
  45.    -(j)-
  46.      /juanca
  47.   }
  48.   ComonDlg,
  49.   fNameDlg,  { tFileNameDlg OBJECT }
  50.   FontDlg,
  51.   MyPrn_,    { tMyPrinter   OBJECT  that uses BWCC}
  52.   MyOpen_,   { tMyOpenDlg   OBJECT  that uses BWCC}
  53.   UsrWin_,
  54.   Port_
  55.   ;
  56.  
  57.   {
  58.     \\\
  59.    -(j)-
  60.      /juanca
  61.   }
  62.   {changed resource file }
  63. {$R COMOSAMP }
  64. {$I CDLG.INC } {just some little id_...Whatever }
  65.  
  66. const
  67.  
  68. { Resource IDs }
  69.  
  70.   id_Menu    = 100;
  71.   id_About   = 100;
  72.   id_Icon    = 100;
  73.  
  74. { Menu command IDs }
  75.  
  76.   cm_FileOpen = 101;
  77.   cm_Color    = 103;
  78.   cm_Font     = 104;
  79.  
  80.  
  81.   {
  82.     \\\
  83.    -(j)-
  84.      /juanca
  85.   }
  86.   {new commands }
  87.   cm_FilePrint        = 110;
  88.   cm_FilePrinterSetup = 111;
  89.   cm_FileUseBWCC      = 112;
  90.  
  91. { Other Constants }
  92.  
  93.   FlagWidth   = 251;
  94.   FlagHeight  = 180;
  95.  
  96. type
  97.  
  98. { Filename string }
  99.  
  100.   TFilename = array [0..255] of Char;
  101.  
  102. { Application main window }
  103.  
  104.   PCommDlgsWindow = ^TCommDlgsWindow;
  105.   TCommDlgsWindow = Object(tUsrWin)  {base type changed to tUsrWin }
  106.                                      {  \\\                        }
  107.     fontPointsBy10 :Longint;         { -(j)-                       }
  108.     ALogFont       : TLogFont;            {   /juanca                   }
  109.     ColorRef       : LongInt;
  110.     myPrinter      : tMyPrinter;
  111.     useBWCC        : Boolean;
  112.  
  113.     constructor Init(AParent: PWindowsObject; AName: PChar);
  114.     destructor  Done; virtual;
  115.  
  116.     procedure MakeDefaultFont;
  117.     procedure SetupWindow; virtual;
  118.  
  119.   {
  120.     \\\
  121.    -(j)-
  122.      /juanca
  123.   }
  124.   { removed the paint method, now use upaint thats compatible with printing}
  125.     procedure
  126.     upaint(dc :pPort; bound :tRect; erased :Boolean);
  127.       virtual;
  128.  
  129.     procedure CMColor(var Msg: TMessage);
  130.       virtual cm_First + cm_Color;
  131.     procedure CMFileOpen(var Msg: TMessage);
  132.       virtual cm_First + cm_FileOpen;
  133.     procedure CMFonts(var Msg: TMessage);
  134.       virtual cm_First + cm_Font;
  135.  
  136.   {
  137.    \\\
  138.    -(j)-
  139.      /juanca
  140.   }
  141.   { new commands }
  142.     procedure
  143.     CMFilePrint(var msg :tMessage);
  144.       virtual
  145.         cm_First+cm_FilePrint;
  146.     procedure
  147.     CMFilePrinterSetup(var msg :tMessage);
  148.       virtual
  149.         cm_First+cm_FilePrinterSetup;
  150.     procedure
  151.     CMFileUseBWCC(var msg :tMessage);
  152.       virtual
  153.         cm_First+cm_FileUseBWCC;
  154.   END; {tCommonDlgsWindow }
  155.  
  156. { Application object }
  157.  
  158.   PCommDlgApp = ^TCommDlgApp;
  159.   TCommDlgApp = Object(TApplication)
  160.     procedure InitMainWindow; virtual;
  161.   end;
  162.  
  163.  
  164.  
  165.  
  166. { Initialized globals }
  167.  
  168. const
  169.   DemoTitle: PChar = 'Common Dialogs Demo';
  170.  
  171. { Global variables }
  172.  
  173. var
  174.   App: TCommDlgApp;
  175.  
  176.  
  177.  
  178.   {
  179.     \\\
  180.    -(j)-
  181.      /juanca
  182.   }
  183.   {NOTICE THIS FUNCTION
  184.   it takes a tLogFont *as value parameter* (no changes to original) and
  185.   creates a GDI font object adecuate for the DeviceContext
  186.   taking a PointSize x 10  parameter
  187.   }
  188.   FUNCTION
  189.   createFontInPointsForDC(hdc :tHandle; px10Size :Word; lfont :tLogFont):tHandle;
  190.     begin
  191.       lFont.lfHeight := -(px10Size*getDeviceCaps(hdc, LOGPIXELSY)) div 720;
  192.       createFontInPointsForDC  := createFontIndirect(lFont);
  193.     end;
  194.  
  195.  
  196. { TCommDlgsWindow Methods }
  197.  
  198. { Constructs an instance of TCommDlgsWindow.  Loads the menu and
  199.   initialize the wave file's "FileName" and the text's initial RGB
  200.   color value.
  201. }
  202. constructor TCommDlgsWindow.Init(AParent: PWindowsObject; AName: PChar);
  203. begin
  204.   tUsrWin.Init(AParent, AName);
  205.   Attr.Menu:= LoadMenu(HInstance, PChar(id_Menu));
  206.  
  207.   ColorRef := RGB(0, 0, 255);
  208.   fontPointsBy10 := 720;
  209.   myPrinter.init;
  210.   useBWCC   := FALSE;
  211. end;
  212.  
  213. { Destroys an instance of the TCommDlgsWindow by disposing of its
  214.   "FlagMap" image and Font.  Then calls on ancestral destructor to
  215.   complete the shutdown.
  216. }
  217. destructor TCommDlgsWindow.Done;
  218. begin
  219.   myPrinter.done;
  220.   tUsrWin.Done;
  221. end;
  222.  
  223. { Sets up an Italic, Times New Roman, font handle used as the default
  224.   Font by TCommDlgsWindow in its Paint method.
  225. }
  226. procedure TCommDlgsWindow.MakeDefaultFont;
  227. begin
  228.   FillChar(ALogFont, SizeOf(TLogFont), #0);
  229.   with ALogFont do
  230.   begin
  231.     lfHeight        := 96;     {Make a large font                 }
  232.     lfWeight        := 700;    {Indicate a Bold attribute         }
  233.     lfItalic        := 1;      {Non-zero value indicates italic   }
  234.     lfUnderline     := 1;      {Non-zero value indicates underline}
  235.     lfOutPrecision  := Out_Stroke_Precis;
  236.     lfClipPrecision := Clip_Stroke_Precis;
  237.     lfQuality       := Default_Quality;
  238.     lfPitchAndFamily:= Variable_Pitch;
  239.     StrCopy(lfFaceName, 'Times New Roman');
  240.   end;
  241. end;
  242.  
  243. { Establishes the font and the "FlagMap" bitmap image used in
  244.   TCommDlgsWindow's Paint method.  The FlagMap is held as an instance
  245.   variable until the window is closed.
  246. }
  247. procedure TCommDlgsWindow.SetUpWindow;
  248. begin
  249.   tUsrWin.SetupWindow;
  250.   MakeDefaultFont;
  251. end;
  252.  
  253. { Displays the bitmap held in "FlagMap".  Then surrounds this flag map
  254.   with the string 'TP Win 3.1' in the selected font and text color.
  255. }
  256. procedure TCommDlgsWindow.upaint(dc :pPort; bound :tRect; erased :Boolean);
  257. var
  258.   S        : array [0..100] of Char;
  259.   paintDC  : HDC;
  260.   Dims     : LongInt;
  261.   oldFont,
  262.   font     : tHandle;
  263. begin
  264.   paintDC := dc^.context;
  265.  
  266.   { formula for calculating fontHeight for WYSYWIG,
  267.     size := -(PIXELSxINCH * Points)/72  }
  268.   font := createFontInPointsForDC(paintDC, fontPointsBy10, aLogFont);
  269.  
  270.   StrCopy(S, 'TP ');
  271.   oldFont := SelectObject(PaintDC, font);
  272.   SetTextColor(PaintDC, ColorRef);
  273.   TextOut(PaintDC, 0, 0, S, StrLen(S));
  274.   Dims := GetTextExtent(PaintDC, S, StrLen(S));
  275.  
  276.  
  277.   StrCopy(S, ' Win 3.1');
  278.   TextOut(PaintDC, (LoWord(Dims) ), 0, S, StrLen(S));
  279.  
  280.   deleteObject(selectObject(paintDC, oldFont));
  281. end;
  282.  
  283. { Displays the "Open File Dialog" from Common dialogs and permit the user
  284.   to select from among the available Wave files.  Then play the sound
  285.   found in the file using "SndPlaySound".
  286. }
  287. procedure TCommDlgsWindow.CMFileOpen(var Msg: TMessage);
  288. var
  289.   {
  290.     \\\
  291.    -(j)-
  292.      /juanca
  293.   }
  294.   { removed declarations }
  295. {$ifdef NOT_NEEDED}
  296.   OpenFN      : TOpenFileName;
  297.   Filter      : array [0..100] of Char;
  298.   FullFileName: TFilename;
  299. {$endif}
  300.   WinDir      : array [0..145] of Char;
  301.   dlg         :pMyOpenDlg;
  302. begin
  303.   GetWindowsDirectory(WinDir, SizeOf(WinDir));
  304.   SetCurDir(WinDir);
  305.  
  306.   if useBWCC
  307.   then
  308.     dlg := new(pMyOpenDlg, init(@Self, 'OPEN_DLG', TRUE)) { TRUE means OpenDlg, FALSE SaveAsDlg }
  309.   else
  310.     dlg := new(pMyOpenDlg, init(@Self, nil, TRUE)); { TRUE means OpenDlg, FALSE SaveAsDlg }
  311.   if dlg <> nil
  312.   then begin
  313.     if (dlg^.execute = idOk) 
  314.     then
  315.       with dlg^, openFileName
  316.       do begin
  317.         if strComp(filePath+nFileExtension, 'WAV') = 0
  318.         then
  319.           SndPlaySound(dlg^.filePath, 1);   {Second parameter must be 1}
  320.         case option
  321.         of
  322.           id_Superb :
  323.             messageBox( hwindow,
  324.                         'So you like my dialogs...Thanks :->',
  325.                         'Juanca',
  326.                         mb_IconExclamation or mb_Ok); 
  327.           id_JustOk :
  328.             messageBox( hwindow,
  329.                         'My Dlg''s are just ok?'#10+
  330.                         'Well...I diddn''t really work too hard onthem :-)',
  331.                         'Juanca',
  332.                         mb_IconQuestion or mb_Ok);
  333.           id_YourOwn:
  334.             messageBox( hwindow,
  335.                         'If you don''t like theese...'#10+
  336.                         'Better go for it...start writing your own Common Dlgs :-\',
  337.                         'Juanca',
  338.                         mb_IconStop or mb_Ok);
  339.         end
  340.       end;
  341.     dlg^.free
  342.   end
  343. end;
  344.  
  345. { Displays the "Choose Color" dialog from the common dialogs unit.
  346.   Permits an initial value to be inserted and custom colors to be
  347.   developed. Note, custom colors are not used by the "ChooseFont"
  348.   dialog from common dialogs.
  349. }
  350. procedure TCommDlgsWindow.CMColor(var Msg: TMessage);
  351. type
  352.   TLongAry = array [0..15] of Longint;
  353. const
  354.   { Establishes a set of custom colors in 15 shades of blue }
  355.   CustColors: TLongAry = (
  356.     $000000, $100000, $200000, $300000,
  357.     $400000, $500000, $600000, $700000,
  358.     $800000, $900000, $A00000, $B00000,
  359.     $C00000, $D00000, $E00000, $F00000);
  360. var
  361.   ChooseClr: TChooseColor;
  362.   i        : Integer;
  363. begin
  364.   with ChooseClr do
  365.   begin
  366.     HWndOwner   := HWindow;
  367.     lStructSize := Sizeof(TChooseColor);
  368.     rgbResult   := ColorRef;
  369.     lpCustColors:= @CustColors;
  370.     Flags       := cc_FullOpen or cc_RGBInit;
  371.       {Allow custom colors and the initialization through rgbResult}
  372.   end;
  373.   if not ChooseColor(ChooseClr) then
  374.     Exit;
  375.   ColorRef := ChooseClr.RGBResult;
  376.   InvalidateRect(HWindow, nil, True);
  377. end;
  378.  
  379. { Displays the ChooseFont dialog to permit the selection of a font which
  380.   is returned as a TLogFont.  Then a font handle is created from this
  381.   logical font information.
  382. }
  383. procedure TCommDlgsWindow.CMFonts(var Msg: TMessage);
  384. var
  385.   ChooseRec: TChooseFont;
  386.   Colors   : LongInt;
  387.   Style    : array [0..100] of Char;
  388.   TempFont : TLogFont;
  389.   result   : Longint;
  390.   cfdlg    : pChooseFontDlg;
  391. begin
  392.   FillChar(ChooseRec, SizeOf(ChooseRec), #0);
  393.   with ChooseRec do
  394.   begin
  395.     lStructSize:= SizeOf(TChooseFont);
  396.     hdc        := myPrinter.context;
  397.     lpLogFont  := @ALogFont;
  398.     Flags      := cf_Both or cf_WYSIWYG or cf_Effects or cf_InitToLogFontStruct;
  399.     rgbColors  := ColorRef;
  400.     lpszStyle  := Style;
  401.     iPointSize := fontPointsBy10;
  402.   end;
  403.  
  404.  
  405.   {
  406.      \\\
  407.     -(j)-
  408.       /juanca
  409.   }
  410.   { this is the easy way to change the dialog "look"}
  411.   if useBWCC
  412.   then begin
  413.     cfdlg := new(pChooseFontDlg, init(@Self, 'CHOOSEF_31', @chooseRec));
  414.     if (cfdlg = nil) or (cfdlg^.execute <> id_Ok)
  415.     then
  416.         Exit;
  417.   end
  418.   else if not ChooseFont(ChooseRec)
  419.   then begin
  420.     result := CommDlgExtendedError; { juanca: this is so you can wath with a debugger }
  421.     Exit;
  422.   end;
  423.  
  424. { Update the Font and Color data fields, then cause the window to be
  425.   repainted.
  426. }
  427.   ColorRef:= ChooseRec.rgbColors;
  428.   fontPointsBy10 := chooseRec.iPointSize;
  429.   InvalidateRect(HWindow, nil, True);
  430. end;
  431.  
  432.  
  433.     procedure
  434.     TCommDlgsWindow.
  435.     {}
  436.     CMFilePrint(var msg :tMessage);
  437.       begin
  438.         myPrinter.print(@self, 'JUANCA')
  439.       end;
  440.  
  441.     procedure
  442.     TCommDlgsWindow.
  443.     {}
  444.     CMFilePrinterSetup(var msg :tMessage);
  445.       begin
  446.         myPrinter.setup(@self)
  447.       end;
  448.  
  449.     procedure
  450.     TCommDlgsWindow.
  451.     {}
  452.     CMFileUseBWCC(var msg :tMessage);
  453.       begin
  454.         useBWCC := not useBWCC;
  455.         if useBWCC
  456.         then
  457.           checkMenuItem(attr.menu, cm_FileUseBWCC, mf_ByCommand or mf_Checked)
  458.         else
  459.           checkMenuItem(attr.menu, cm_FileUseBWCC, mf_ByCommand);
  460.         myPrinter.setBWCCUse(useBWCC)
  461.       end;
  462.  
  463.  
  464. { TCommDlgApp Methods }
  465.  
  466. procedure TCommDlgApp.InitMainWindow;
  467. begin
  468.   MainWindow := New(PCommDlgsWindow, Init(nil, Application^.Name));
  469. end;
  470.  
  471.  
  472. { Main program }
  473.  
  474. begin
  475.   App.Init(DemoTitle);
  476.   App.Run;
  477.   App.Done;
  478. end.
  479.